home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / Modules / describe.em < prev    next >
Lisp/Scheme  |  1992-10-06  |  3KB  |  110 lines
  1. ;;; describe various objects
  2. ;;; version 1.0
  3. ;;; RJB May 92
  4.  
  5. (defmodule describe
  6.  
  7.   ((rename ((function-lambda-list fll)) standard0))
  8.  
  9.   ()
  10.  
  11.   ; first fix fll
  12.   (defgeneric function-lambda-list (fun))
  13.  
  14.   (defmethod function-lambda-list ((f object))
  15.     (fll f))
  16.  
  17.   (defmethod function-lambda-list ((gf generic-function))
  18.     (let ((meths (generic-function-methods gf)))
  19.       (if (atom meths)
  20.       "unknown"
  21.       (mkargs (length (method-signature (car meths)))))))
  22.  
  23.   (defmethod function-lambda-list ((c continuation))
  24.     '(a))
  25.  
  26.   (defun mkargs (n)
  27.     (if (= n 0) ()
  28.     (cons (vector-ref #(@ a b c d e f g h i j k l m n o
  29.                   p q r s t u v w x y z) n)
  30.           (mkargs (- n 1)))))
  31.  
  32.   (defgeneric describe (obj))
  33.  
  34.   (defmethod describe ((cl class))
  35.     (format t "The class ~a is an instance of ~a~%"
  36.         cl (class-of cl))
  37.     (format t "class precedence list: ~a~%"
  38.         (class-precedence-list cl))
  39.     (format t "direct superclasses:   ~a~%"
  40.         (class-direct-superclasses cl))
  41.     (format t "direct subclasses:     ~a~%"
  42.         (class-direct-subclasses cl))
  43.     (when (class-direct-slot-descriptions cl)
  44.       (format t "direct slots~%------------~%")
  45.       (mapcar describe-slot
  46.           (class-direct-slot-descriptions cl)))
  47. ;    (when (class-constructors cl)
  48. ;      (format t "------------~%")
  49. ;      (format t "class constructors:~%")
  50. ;      (mapcar print (class-constructors cl)))
  51.     t)
  52.  
  53.   (defmethod describe ((inst object))
  54.     (format t "~a is an instance of ~a~%"
  55.         inst (class-of inst))
  56.     (describe-slot-values (class-direct-slot-descriptions (class-of inst))
  57.               inst)
  58.     t)    
  59.  
  60.   (defun describe-slot (sl)
  61.     (format t "slot name: ~a~%"
  62.         (slot-description-name sl))
  63.     (format t "position:  ~a~%"
  64.         (slot-description-position sl))
  65.     (format t "initargs:  ~a~%"
  66.         (slot-description-initargs sl)))
  67.  
  68.   (defun describe-slot-values (slotds inst)
  69.     (when slotds
  70.       (let ((name (slot-description-name (car slotds))))
  71.         (format t "slot ~a: ~a~%"
  72.             name
  73.             (slot-value inst name))
  74.         (describe-slot-values (cdr slotds) inst))))
  75.  
  76.   (defmethod describe ((f function))
  77.     (call-next-method)
  78.     (format t "argument list: ~a~%" (function-lambda-list f))
  79.     t)
  80.  
  81.   (defmethod describe ((gf generic-function))
  82.     (call-next-method)
  83.     (format t "methods signatures:~%")
  84.     (mapcar (lambda (m)
  85.           (format t "~a~%" (method-signature m)))
  86.         (generic-function-methods gf))
  87.     t)
  88.  
  89.   (defmethod describe ((m method))
  90.     (call-next-method)
  91. ;    (format t "generic function: ~a~%" (method-generic-function m))      
  92.     (format t "signature: ~a~%" (method-signature m))
  93.     t)
  94.  
  95.   (defmethod describe ((th thread))
  96.     (call-next-method)
  97.     (format t "thread state: ~a~%" (thread-state th))
  98.     t)
  99.  
  100.   (defmethod describe ((sl slot-description))
  101.     (call-next-method)
  102.     (describe-slot sl)
  103.     t)
  104.  
  105.   ; semaphores
  106.  
  107.   (export describe)
  108.  
  109. )
  110.